perm filename FORS[1,LMM] blob
sn#031685 filedate 1973-03-28 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00008 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DE PROG1(A B)A)
C00007 00003 (DE REMOVEOF (L)
C00013 00004 (DM VARNAME (VARNL)
C00028 00005 (DE | (STR VAL)
C00035 00006 (DM FOR (FOR-EXPRESSION)
C00037 00007 (DE FULLEXPANSION (X)
C00039 00008 (DE DEFAULT (FIELD VALUE) (DEFLIST (LIST VALUE)@ RECDEFAULT))))))))))
C00043 ENDMK
C⊗;
(DE PROG1(A B)A)
(DE DEFLIST (L PROP) (PROG (VAL)
LP
(COND ((NULL L) (RETURN VAL)))
(PUTPROP (CAAR L) (CADAR L) PROP)
(SETQ VAL (CONS (CAAR L) VAL))
(SETQ L (CDR L))
(GO LP)))))))))))
(DE RPLACNODE (OLD NEW) (PROG2 (RPLACA OLD (CAR NEW))
(RPLACD OLD (CDR NEW)))))))))))
(DE MAKEMAKECOPY (X)
(COND ((MEMQ (CAR X)
(QUOTE (LIST COPY)))
X)
((AND (EQ (CAR X) (QUOTE APPEND))(CDDR X)) X)
(T (LIST (QUOTE APPEND)
X NIL ))))
(DE REMOVEIS (FORM)
(COND ((NULL FORM)
NIL)
((EQ (CAR FORM)
(QUOTE IS))
(REMOVEIS (CDR FORM)))
((EQ (CAR FORM)
(QUOTE =))
(REMOVEIS (CDR FORM)))
(T (CONS (CAR FORM)
(REMOVEIS (CDR FORM))))))
(DE RECORD (NAME FIELD)
(PROG NIL (PUTPROP NAME FIELD (QUOTE RECORD))
(PUTPROP NAME (LIST (QUOTE LAMBDA)
(QUOTE (RECORDVAR))
(LIST @RPLACNODE @RECORDVAR
(LIST (QUOTE COMPOSE)
(QUOTE (REMOVEIS RECORDVAR))
(LIST (QUOTE QUOTE)
FIELD))))
(QUOTE MACRO))
(RECDO FIELD (QUOTE X))))
(DE RECDO (FORMAT DEF)
(COND
((NULL FORMAT)
NIL)
((NOT (ATOM FORMAT))
(RECDO (CAR FORMAT)
(LIST (QUOTE CAR)
DEF))
(RECDO (CDR FORMAT)
(LIST (QUOTE CDR)
DEF)))
(T (PUTPROP FORMAT
(LIST (QUOTE LAMBDA)
(QUOTE (RECORDFIELDVAR))
(LIST @RPLACNODE @RECORDFIELDVAR
(LIST (QUOTE SUBST)
(QUOTE (COND
((NULL (CDDR (SETQ
RECORDFIELDVAR
(REMOVEOF
RECORDFIELDVAR))))
(CADR RECORDFIELDVAR))
(T(CDR RECORDFIELDVAR))))
(QUOTE (QUOTE X))
(LIST (QUOTE QUOTE)
DEF))))
(QUOTE MACRO)))))
(DE REMOVEOF (L)
(COND ((NULL L)
NIL)
((EQ (CAR L)
(QUOTE OF))
(REMOVEOF (CDR L)))
(T (CONS (CAR L)
(REMOVEOF (CDR L))))))
(DE COMPOSE (L FIELD)
(COND ((EQ (CADR L)
(QUOTE FROM))
(COND ((ATOM (CADDR L))
(COMPOSE1 L FIELD (CADDR L)))
(T (LIST (LIST (QUOTE LAMBDA)
(QUOTE (COMPOSEVAR))
(COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))
(CADDR L)))))
(T (COMPOSE1 L FIELD (QUOTE COMPOSEVAR)))))
(DE COMPOSE1 (L FIELD DEF)
(PROG (K)
(RETURN
(COND ((SETQ K (COMPOSE2 L FIELD DEF))
(CAR K))
(T (COMPOSE3 L FIELD DEF))))))
(DE
COMPOSE2
(L FIELD DEF)
(COND
((NULL FIELD)
NIL)
((ATOM FIELD)
(COND ((GET L FIELD)
(LIST (SUBST DEF (QUOTE **)
(GET L FIELD))))
(T NIL)))
((EQ (CAR FIELD)
(QUOTE ID))
(LIST (LIST (QUOTE QUOTE)
(CDR FIELD))))
(T
(PROG (KA KD)
(SETQ KD (COMPOSE2 L (CDR FIELD)
(LIST (QUOTE CDR)
DEF)))
(SETQ KA (COMPOSE2 L (CAR FIELD)
(LIST (QUOTE CAR)
DEF)))
(COND ((AND (NULL KA)
(NULL KD))
(RETURN NIL)))
(RETURN
(LIST (#CONS (COND (KA (CAR KA))
(T (COMPOSE1 L (CAR FIELD)
(LIST (QUOTE CAR)
DEF))))
(COND (KD (CAR KD))
(T (COMPOSE1 L (CDR FIELD)
(LIST (QUOTE CDR)
DEF)))))))))))
(DE COMPOSE3 (L FIELD DEF)
(COND ((EQ (QUOTE FROM)
(CADR L))
DEF)
(T (COMPOSE4 FIELD))))
(DE COMPOSE4 (FIELD)
(COND ((NULL FIELD)
NIL)
((ATOM FIELD)
((LAMBDA (X)
(COND (X (LIST (QUOTE QUOTE)
X))
(T NIL)))
(GET FIELD (QUOTE RECDEFAULT))))
(T (#CONS (COMPOSE4 (CAR FIELD))
(COMPOSE4 (CDR FIELD))))))
(DE #CONS (CARPART CDRPART)
(COND ((NOT CDRPART)(LIST(QUOTE LIST)CARPART))
((EQ(CAR CDRPART)(QUOTE LIST))
(CONS (QUOTE LIST)
(CONS CARPART (CDR CDRPART))))
(T (LIST (QUOTE CONS)
CARPART CDRPART))))))))))))))
(DM VARNAME (VARNL)
(LIST @| (CADR VARNL) @VAR)))))))))
(DM GONEXTN (DUMMY) @(LIST (QUOTE GO)
(COND ((EQUAL N 1)
(QUOTE RETURN))
(T (| (QUOTE NEXT)
(SUB1 N))))))
(DM PLUSSIGNTESTSET (TSLS)
(LIST @CAR (LIST @SETQ @TESTSET (LIST @CONS(CADR TSLS)@TESTSET)))))))))))
(DM PLUSSIGNPV (PVL)
(LIST @CAR (LIST @SETQ @PV (LIST @CONS(CADR PVL)@PV))))))))))))))
(DM INITL (INITLLS)
(LIST @PROG1 (LIST @SETQ @TEM(CADR INITLLS))(LIST @SETQ @INIT (LIST @CONS
(LIST @SETIT @TEM(CADDR INITLLS))
@INIT)))))))))))))))))
(DM PLUSSIGNNEXT (ITEMLIST)
(LIST @ CAR (LIST @SETQ @NEXT (LIST @CONS (CADR ITEMLIST) @NEXT)))))))
(DE *FOR (L)
(PROG
(N FV PV EPILOGUE PROLOGUE DOFORM DOTYPE VAR RANGE LST VARNEXT
NEXT NEXTS N2 N3 INIT TESTSET DOVAL TEM)
(SETQ N 1)
FORLOOP
(COND ((EQ (CAR L)
(QUOTE NEW))
(PLUSSIGNPV (CAR (SETQ L (CDR L))))))
(SETQ VAR (CAR L))
(SETQ RANGE (CADDR L))
(PLUSSIGNNEXT (SETQ VARNEXT (VARNAME (QUOTE NEXT))))
(COND
((EQ (CADR L)
(QUOTE IN))
(PLUSSIGNTESTSET (CONDIT (NEGATE (INITL (PLUSSIGNPV (SETQ
LST
(VARNAME (QUOTE LIST)))
)
RANGE))
(GONEXTN)))
(PLUSSIGNTESTSET (SETIT VAR (LIST (QUOTE CAR)
LST)))
(PLUSSIGNNEXT (SETIT LST (LIST (QUOTE CDR)
LST))))
((EQ (CADR L)
(QUOTE ON))
(PLUSSIGNTESTSET (CONDIT (NEGATE VAR)
(GONEXTN)))
(PLUSSIGNNEXT (SETIT (INITL VAR RANGE)
(LIST (QUOTE CDR)
VAR))))
((EQ (CADR L)
(QUOTE :=))
(SETQ N2 (COND ((ATOM (CADR RANGE))
(CADR RANGE))
(T (INITL (PLUSSIGNPV (VARNAME (QUOTE MAX)))
(CADR RANGE)))))
(SETQ N3 (COND ((CDDR RANGE)
(COND
((ATOM (CADDR RANGE))
(CADDR RANGE))
(T (INITL (PLUSSIGNPV (VARNAME (QUOTE INC)))
(CADDR RANGE)))))
((AND (NUMBERP (CAR RANGE))
(NUMBERP (CADR RANGE))
(GREATERP (CAR RANGE)
(CADR RANGE)))
-1)
(T 1)))
(INITL VAR (CAR RANGE))
(PLUSSIGNTESTSET (CONDIT
(COND ((NOT (NUMBERP N3))
(LIST (QUOTE COND)
(LIST (LIST (QUOTE MINUSP)
N3)
(LIST (QUOTE LESSP)
VAR N2))
(LIST T (LIST (QUOTE OR)
(LIST (QUOTE ZEROP)
N3)
(LIST (QUOTE GREATERP)
VAR N2)))))
((MINUSP N3)
(LIST (QUOTE LESSP)
VAR N2))
(T (LIST (QUOTE GREATERP)
VAR N2)))
(GONEXTN)))
(PLUSSIGNNEXT (SETIT VAR (LIST (QUOTE PLUS)
VAR N3))))
((EQ (CADR L)
(QUOTE IS))
(PLUSSIGNTESTSET (SETIT VAR RANGE)))
(T (ERR @INVALID-FOR-TYPE)))
(SETQ L (CDDDR L))
ASLOOP
(COND ((EQ (CAR L)
(QUOTE AS))
(SETQ L (CDR L))
(SETQ NEXTS (APPEND NEXTS NEXT))
(SETQ NEXT NIL)
(GO FORLOOP))
((MEMQ (CAR L)
(QUOTE (IF WHEN)))
(PLUSSIGNTESTSET (CONDIT (NEGATE (CADR L))
(LIST (QUOTE GO)
VARNEXT)))
(SETQ L (CDDR L)))
((EQ (CAR L)
(QUOTE UNTIL))
(PLUSSIGNNEXT (CONDIT (CADR L)
(GONEXTN)))
(SETQ L (CDDR L)))
((EQ (CAR L)
(QUOTE WHILE))
(PLUSSIGNTESTSET (CONDIT (NEGATE (CADR L))
(GONEXTN)))
(SETQ L (CDDR L)))
(T (GO FORTEST)))
(GO ASLOOP)
FORTEST
(SETQ PROLOGUE (APPEND TESTSET (LIST (| (QUOTE LOOP)
N))
INIT PROLOGUE))
(SETQ EPILOGUE (CONS (| (QUOTE NEXT)
N)
(APPEND (REVERSE NEXT)
(REVERSE NEXTS)
(CONS (LIST (QUOTE GO)
(| (QUOTE LOOP)
N))
EPILOGUE))))
(SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS NIL))))
(COND ((EQ (CAR L)
(QUOTE FOR))
(SETQ L (CDR L))
(SETQ N (ADD1 N))
(GO FORLOOP)))
(SETQ DOTYPE (CAR L))
(SETQ DOVAL (CAR (LAST L)))
(PLUSSIGNPV (QUOTE FOR-VALUE))
(SETQ FV (QUOTE FOR-VALUE))
(SETQ DOFORM (COND ((MEMQ DOTYPE (QUOTE (AND OR)))
(CONDIT (LIST (COND ((EQ DOTYPE (QUOTE AND))
(INITL (QUOTE FOR-VALUE)
T)
(QUOTE NOT))
(T (QUOTE PROG2)))
(SETIT (QUOTE FOR-VALUE)
DOVAL))
(QUOTE (RETURN FOR-VALUE))))
((MEMQ DOTYPE (QUOTE (PROGN PROG2)))
(SETIT (QUOTE FOR-VALUE)
DOVAL))
((EQ DOTYPE (QUOTE DO))
DOVAL)
(T (SETIT (QUOTE FOR-VALUE)
(COND ((EQ DOTYPE (QUOTE LIST))
(LIST (QUOTE NCONC)
(QUOTE FOR-VALUE)
(LIST (QUOTE LIST)
DOVAL)))
((EQ DOTYPE (QUOTE NCONC))
(LIST (QUOTE NCONC)
(QUOTE FOR-VALUE)
DOVAL))
((EQ DOTYPE (QUOTE XLIST))
(LIST (QUOTE CONS)
DOVAL
(QUOTE FOR-VALUE)))
((EQ DOTYPE (QUOTE APPEND))
(LIST (QUOTE NCONC)
(QUOTE FOR-VALUE)
(MAKEMAKECOPY DOVAL)))
(T (LIST DOTYPE DOVAL
(QUOTE FOR-VALUE))))))
))
(COND ((EQ (CAR (SETQ L (CDR L)))
(QUOTE FIRST))
(INITL (QUOTE FOR-VALUE)
(CADR L))
(SETQ L (CDDR L)))
((MEMQ DOTYPE (QUOTE (PLUS IPLUS TIMES ITIMES MAX MIN)))
(INITL (QUOTE FOR-VALUE)
(CDR (ASSOC DOTYPE (QUOTE ((PLUS . 0)
(MAX . -99999)
(MIN . 99999)
(IPLUS . 0)
(TIMES . 1)
(ITIMES . 1))))))))
(RETURN (CONS (QUOTE PROG)
(CONS PV (APPEND INIT (REVERSE PROLOGUE)
(REVERSE (CDR (REVERSE L)))
(LIST DOFORM)
EPILOGUE
(LIST (QUOTE RETURN)
(LIST (QUOTE RETURN)
FV))))))))
(DE | (STR VAL)
(READLIST (NCONC (EXPLODE STR)
(CONS (QUOTE *)
(EXPLODE VAL)))))
(DE CONDIT (PRD DO)
(LIST (QUOTE COND)
(LIST PRD DO)))
(DE SETIT (VAR VAL)
(COND ((NOT (EQUAL VAR VAL))
(LIST (QUOTE SETQ)
VAR VAL))
(T NIL)))
(DE NEGATE (EXP)
(COND ((MEMQ (CAR EXP)
(QUOTE (NOT NULL)))
(CADR EXP))
(T (LIST (QUOTE NOT)
EXP))))
(DE *IF (L)
(COND (L (CONS (CONS (CAR L)
(COND ((NOT (EQ (CADR L)
(QUOTE THEN)))
(ERROR L
(QUOTE "NO CORRESPONDING THEN IN IF")))
(T (SETQ L (CDDR L))
(THENCLAUSE))))
(COND ((NULL L)
NIL)
((EQ (CAR L)
(QUOTE ELSEIF))
(*IF (CDR L)))
((EQ (CAR (SETQ L (CDR L)))
(QUOTE IF))
(*IF (CDR L)))
(T (LIST (CONS T (THENCLAUSE)))))))
(T NIL)))
(DE THENCLAUSE NIL (COND ((OR (NULL L)
(MEMQ (CAR L)
(QUOTE (ELSE ELSEIF))))
(LIST NIL))
((OR (NOT (CDR L))
(MEMQ (CADR L)
(QUOTE (ELSE ELSEIF))))
((LAMBDA (X Y)
X)
(LIST (CAR L))
(SETQ L (CDR L))))
(T (CONS (CAR L)
(PROG2 (SETQ L (CDR L))
(THENCLAUSE))))))
(DE QUOTEIT1 (X M)
(COND ((OR (NULL X)
(NUMBERP X)
(EQ X T))
X)
((SETQ M (QUOTEIT2 X M))
M)
(T (LIST (QUOTE QUOTE)
X))))
(DE
QUOTEIT2
(X N)
(COND
((ATOM X)
NIL)
((EQ (CAR X)
(QUOTE ¬))
(COND ((ATOM (CDR X))
(CDR X))
((NULL (CDDR X))
(LIST (QUOTE LIST)
(CADR X)))
(T ((LAMBDA (D E)
(COND ((EQ (CAR D)
(QUOTE LIST))
(CONS (QUOTE LIST)
(CONS E (CDR D))))
(T (LIST (QUOTE CONS)
E D))))
(QUOTEIT1 (CDDR X))
(CADR X)))))
((NULL (CDR X))
(COND ((SETQ N (QUOTEIT2 (CAR X)
N))
(LIST (QUOTE LIST)
N))
(T NIL)))
(T (PROG (M)
(SETQ M (QUOTEIT2 (CAR X)
N))
(SETQ N (QUOTEIT2 (CDR X)
N))
(COND ((AND (NULL M)
(NULL N))
(RETURN NIL)))
(COND ((AND (NULL M)
(SETQ M (CAR X))
(NOT (NUMBERP M))
(NOT (EQ M T)))
(SETQ M (LIST (QUOTE QUOTE)
M))))
(RETURN (COND
((EQ (CAR N)
(QUOTE LIST))
(CONS (CAR N)
(CONS M (CDR N))))
(T (LIST (QUOTE CONS)
M
(COND ((AND (NULL N)
(SETQ N (CDR X))
(NOT (NUMBERP N))
(NOT (EQ N T)))
(LIST (QUOTE QUOTE)
N))
(T N))))))))))
(DM FOR (FOR-EXPRESSION)
(*FOR (CDR FOR-EXPRESSION))))))))))
(DM IF (IF-EXPRESSION)
(CONS (QUOTE COND)
(*IF (CDR IF-EXPRESSION)))))))))
(DM REPLACE (REPLACEXP)
(PROG (REPLACE1 REPLACE2)
(SETQ REPLACE1 (FULLEXPANSION (CADR REPLACEXP)))
(SETQ REPLACE2 (CADDR REPLACEXP))
(RETURN (LIST (COND ((EQ (CAR REPLACE1)
(QUOTE CAR))
(QUOTE RPLACA))
((EQ (CAR REPLACE1)
(QUOTE CDR))
(QUOTE RPLACD))
(ERROR @"REPLACE CAN'T" (LIST REPLACE1
REPLACE2)))
(CADR REPLACE1)
REPLACE2))))))))))))))
(DE FULLEXPANSION (X)
(COND ((MEMQ (CAR X)
(QUOTE (CAAR CADR CDAR CDDR CDDAR CDDDR CDDDAR
CDDDDR CADDAR CADDDR CADAR CADDR CDADAR
CDADDR CAADAR CAADDR CDAAR CDADR CDDAAR
CDDADR CADAAR CADADR CAAAR CAADR CDAAAR
CDAADR CAAAAR CAAADR)))
(LIST (READLIST (LIST (QUOTE C)
(CADR (EXPLODE (CAR X)))
(QUOTE R)))
(LIST (READLIST (CONS (QUOTE C)
(CDDR (EXPLODE (CAR X)))))
(CADR X))))
((GET (CAR X)
(QUOTE MACRO))
(FULLEXPANSION (APPLY (GET (CAR X)
(QUOTE MACRO))
(LIST X))))
(T X)))))))))))
(DE DEFAULT (FIELD VALUE) (DEFLIST (LIST VALUE)@ RECDEFAULT))))))))))
(DE SPECIAL (L) (MAPC (FUNCTION(LAMBDA(X)(PUTPROP X @ (NIL)
@ SPECIAL))) L))))))))
(DE GSET (VAR VAL) (PROG2
(COND ((GET VAR @ SPECIAL))
(T(SPECIAL (LIST VAR))))
(SET VAR VAL)))))))))
(DE ADVISE (FN WHEN WHAT)
(PUTPROP FN
(LIST @ LAMBDA (ARGLIST FN)
(LIST @PROG (CONS @!VALUE(COND((EQ WHEN @ BIND) WHAT)(T NIL)))
(LIST @SETQ @!VALUE (LIST @PROG NIL
(COND ((EQ WHEN @ BEFORE) WHAT) (T NIL))
(LIST @RETURN (SAVEFN1 FN (ARGLIST FN)))))
(COND((EQ WHEN @ AFTER)WHAT)(T NIL))
@(RETURN !VALUE)))
@ EXPR ))))))))))))))))))))))))
(DE ADVISE1(FN WHEN ARGLIST WHAT)
(PUTPROP FN
(LIST @ LAMBDA ARGLIST
(LIST @PROG (CONS @!VALUE(COND((EQ WHEN @ BIND) WHAT)(T NIL)))
(LIST @SETQ @!VALUE (LIST @PROG NIL
(COND ((EQ WHEN @ BEFORE) WHAT) (T NIL))
(LIST @RETURN (SAVEFN1 FN ARGLIST))))
(COND((EQ WHEN @ AFTER)WHAT)(T NIL))
@(RETURN !VALUE)))
@ EXPR )
)))))))))))
(DE SAVEFN1 (FN ARGLIST) (PROG (AT) (SETQ AT (INTERN (GENSYM)))
(COND ((GET FN @ EXPR) (PUTPROP AT (GET FN @ EXPR) @ EXPR))
((GET FN @ SUBR) (PUTPROP AT (GET FN @ SUBR) @ SUBR)))
(RETURN (CONS AT ARGLIST)))))))))))))
(DE ARGLIST (FN)
(FIRSTN @(ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 ARG10)
(NARGS FN )))))
(DE NARGS (FN)
(COND((GET FN @ EXPR)(LENGTH (CADR (GET FN @ EXPR))))
(T 5)))))))))))))))))))))))))
(DE FIRSTN (L N)
(COND ((EQUAL N 0) NIL)
(T(CONS (CAR L) (FIRSTN (CDR L) (SUB1 N)))))))))))))))))